home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / freefnt.com / FFDEMO50.PAS next >
Encoding:
Pascal/Delphi Source File  |  1990-01-19  |  7.9 KB  |  380 lines
  1. USES CRT,GRAPH,FFONT50;
  2.  
  3. VAR driver,mode : integer;
  4.      FontBuffer : array[0..20000] of byte;
  5.  
  6. FUNCTION LoadFont(FN:string):boolean;
  7. VAR f : file;
  8.     r : word;
  9. BEGIN
  10.   {$I-}
  11.   ASSIGN(f,FN);
  12.   RESET(f,1);
  13.   BLOCKREAD(f,FontBuffer,sizeof(fontbuffer),r);
  14.   CLOSE(f);
  15.   LoadFont := (IOResult = 0) and (r>0);
  16.   {$I+}
  17. END;
  18.  
  19. PROCEDURE InitGraphics;
  20. VAR C : integer;
  21. BEGIN
  22.   Driver := detect;
  23.   INITGRAPH(Driver, Mode, '');
  24. {  SetGraphMode(1);}
  25.   IF GraphResult <> 0 THEN HALT(1);
  26. END;
  27.  
  28. PROCEDURE ClearScreen(c:integer);
  29. BEGIN
  30.   SETFILLSTYLE(SOLIDFILL,c);
  31.   BAR(0,0,GETMAXX,GETMAXY);
  32. END;
  33.  
  34. PROCEDURE CircleText( cx,cy,r,Align,GuideColor,dir:integer;
  35.                           st:string;
  36.                           StartA : real);
  37. VAR
  38.   tColor,c,circ,slen : integer;
  39.  TotalR,NextRotation,
  40.       cRotation,oldR : real;
  41.                   AC : ArcCoordsType;
  42.                    S : string;
  43.           CClockwise : boolean;
  44.  
  45. BEGIN
  46.   CClockwise := (dir < 0);
  47.   slen := FFTextWidth(St);
  48.   circ := TRUNC(2*PI*r);
  49.   TotalR := slen/circ*360;
  50.   TColor := GetColor;
  51.  
  52.   SETTEXTJUSTIFY(LEFTTEXT,align);
  53.   FFSetTextOptions(0,TRUE);
  54.  
  55.  
  56.   cRotation := StartA;
  57.  
  58.   FOR c := 1 to LENGTH(st) DO
  59.   BEGIN
  60.  
  61.     S := st[c];
  62.  
  63.     oldR := cRotation;
  64.  
  65.     NextRotation := (FFTextWidth(S)/slen*TotalR);
  66.  
  67.     IF CClockwise
  68.     THEN BEGIN
  69.            cRotation := cRotation + NextRotation;
  70.            SETCOLOR(GuideColor);
  71.  
  72.            ARC(cx,cy,TRUNC(OldR),TRUNC(crotation),r);
  73.  
  74.            GETARCCOORDS(AC);
  75.  
  76.            SETCOLOR(tColor);
  77.  
  78.            WITH AC DO
  79.            BEGIN
  80.  
  81.              FFSetRotation(OldR + NextRotation/2 + 90);
  82.  
  83.              FFStringOutxy(xStart,yStart,S);
  84.  
  85.            END;
  86.          END
  87.     ELSE BEGIN
  88.            cRotation := cRotation - NextRotation;
  89.            SETCOLOR(GuideColor);
  90.  
  91.            ARC(cx,cy,TRUNC(crotation),TRUNC(OldR),r);
  92.  
  93.            GETARCCOORDS(AC);
  94.  
  95.            SETCOLOR(tColor);
  96.  
  97.            WITH AC DO
  98.            BEGIN
  99.  
  100.              FFSetRotation(OldR - NextRotation/2 +270);
  101.  
  102.              FFStringOutxy(xend,yend,S);
  103.  
  104.            END;
  105.          END
  106.   END;
  107. END;
  108.  
  109. PROCEDURE ShadowDemo;
  110. VAR atX,atY : integer;
  111. BEGIN
  112.   atX := GETMAXX div 2;
  113.   atY := GETMAXY div 2;
  114.  
  115.   SETTEXTJUSTIFY(CENTERTEXT,CENTERTEXT);
  116.  
  117.   FFSetTextStyle(@FontBuffer,-30,8);
  118.  
  119.   SETCOLOR(BLUE);
  120.   FFSetTextOptions(-30,TRUE);
  121.   FFStringOutXY(atX ,atY ,'''FreeFont'' 3-D Text');
  122.  
  123.   SETCOLOR(WHITE);
  124.   FFSetTextOptions(30,TRUE);
  125.   FFStringOutXY(atX ,atY ,'''FreeFont'' 3-D Text');
  126.  
  127. END;
  128.  
  129. PROCEDURE Mirrordemo;
  130. BEGIN
  131.   SETFILLSTYLE(SOLIDFILL,BLUE);
  132.   BAR(0,0,GETMAXX,GETMAXY div 2);
  133.  
  134.   SETFILLSTYLE(SOLIDFILL,LIGHTBLUE);
  135.   BAR(0,GETMAXY div 2,GETMAXX,GETMAXY);
  136.  
  137.   SETTEXTJUSTIFY(CENTERTEXT,BOTTOMTEXT);
  138.   FFSetTextStyle(@FontBuffer,0,7);
  139.  
  140.   FFSetTextOptions(-15,TRUE);
  141.   SETCOLOR(WHITE);
  142.   FFStringOutXY(GETMAXX div 2,(GETMAXY div 2) - 2,'''FreeFont'' Mirror');
  143.  
  144.   FFSetTextOptions(195,TRUE);
  145.   SETCOLOR(lightGray);
  146.   FFStringOutXY(GETMAXX div 2,(GETMAXY div 2)+2,'''FreeFont'' Mirror');
  147.  
  148. END;
  149.  
  150. PROCEDURE CircDemoII;
  151. VAR
  152.              Xasp,Yasp : word;
  153.     atX,atY,rad,bColor : integer;
  154.  
  155. BEGIN
  156.   bcolor := LIGHTBLUE;
  157.   GETASPECTRATIO(Xasp,Yasp);
  158.   atX := GETMAXX div 2;
  159.   atY := GETMAXY div 2;
  160.   rad := 140;
  161.  
  162.   SETCOLOR(bColor);
  163.  
  164.   SETFILLSTYLE(SOLIDFILL,BLUE);
  165.   FILLELLIPSE(atX,atY,(rad-5),(rad-5) * longint(Xasp) div Yasp);
  166.  
  167.   FFSetTextStyle(@FontBuffer,0,14);
  168.   FFSetTextOptions(0,TRUE);
  169.   SETTEXTJUSTIFY(CENTERTEXT,BOTTOMTEXT);
  170.   FFStringOutXY(atX,atY,'II');
  171.   FFSetTextStyle(@FontBuffer,0,7);
  172.  
  173.  
  174.   SETCOLOR(BLACK);
  175.   CircleText(atX,atY,rad,TOPTEXT,bColor,-1,'''FreeFont'' Circular Text',180);
  176. END;
  177.  
  178. PROCEDURE CircDemoI;
  179. VAR
  180.              Xasp,Yasp : word;
  181.     atX,atY,rad,bColor : integer;
  182. BEGIN
  183.   bColor := LIGHTBLUE;
  184.   GETASPECTRATIO(Xasp,Yasp);
  185.   atX := GETMAXX div 2;
  186.   atY := GETMAXY div 2;
  187.   rad := 140;
  188.  
  189.   SETCOLOR(bColor);
  190.  
  191.   SETFILLSTYLE(SOLIDFILL,BLUE);
  192.   FILLELLIPSE(atX,atY,rad-10,(rad-10) * longint(Xasp) div Yasp);
  193.  
  194.   FFSetTextStyle(@FontBuffer,0,14);
  195.   FFSetTextOptions(0,TRUE);
  196.   SETTEXTJUSTIFY(CENTERTEXT,BOTTOMTEXT);
  197.   FFStringOutXY(atX,atY,'I');
  198.  
  199.   FFSetTextStyle(@FontBuffer,0,7);
  200.   SETCOLOR(WHITE);
  201.   CircleText(atX,atY,rad,BOTTOMTEXT,bcolor,1,'''FreeFont'' Circular Text',0);
  202. END;
  203.  
  204. PROCEDURE RotateDemo;
  205. BEGIN
  206.   SETTEXTJUSTIFY(LEFTTEXT,BOTTOMTEXT);
  207.  
  208.   FFSetTextStyle(@FontBuffer,90,8);
  209.   FFSetTextOptions(0,TRUE);
  210.  
  211.   SETCOLOR(BLACK);
  212.   FFStringOutXY(60,GETMAXY - 20,'Rotate Text');
  213.  
  214.   SETCOLOR(DarkGray);
  215.   FFSetRotation(60);
  216.   FFStringOutXY(60,GETMAXY - 20,'Rotate Text');
  217.  
  218.   SETCOLOR(LightGray);
  219.   FFSetRotation(30);
  220.   FFStringOutXY(60,GETMAXY - 20,'Rotate Text');
  221.  
  222.   SETCOLOR(WHITE);
  223.   FFSetRotation(0);
  224.   FFStringOutXY(60,GETMAXY - 20,'Rotate Text');
  225.  
  226. END;
  227.  
  228. PROCEDURE LastPage;
  229. VAR atX,atY : integer;
  230. BEGIN
  231.   IF LoadFont('LITT.chr') THEN
  232.   BEGIN
  233.  
  234.  
  235.   FFSetTextStyle(@FontBuffer,0,8);
  236.   FFSetTextOptions(0,FALSE);
  237.  
  238.   SETCOLOR(BLACK);
  239.   SETTEXTJUSTIFY(LEFTTEXT,TOPTEXT);
  240.   atX := 40;
  241.   atY := 10;
  242.   FFStringOutXY(atX,atY,'''FreeFont'' is a Turbo Pascal Unit for v5.0 and v5.5');
  243.   INC(atY,30);
  244.   FFStringOutXY(atX,atY,'of Borland''s Turbo Pascal Compiler.  Source code is');
  245.   INC(atY,30);
  246.   FFStringOutXY(atX,atY,'available by sending $10.00 to :');
  247.   INC(atY,45);
  248.   FFStringOutXY(atX,atY,'Michael E. Garey');
  249.   INC(atY,30);
  250.   FFStringOutXY(atX,atY,'912 Blue Mountain Ln.');
  251.   INC(atY,30);
  252.   FFStringOutXY(atX,atY,'Antioch, TN 37013');
  253.   INC(atY,45);
  254.   FFStringOutXY(atX,atY,'Please specify a 3.5" or 5.25" diskette.');
  255.   END;
  256. END;
  257.  
  258. PROCEDURE FeatureDemo;
  259. BEGIN
  260.   SETTEXTJUSTIFY(LEFTTEXT,TOPTEXT);
  261.  
  262.   FFSetTextStyle(@FontBuffer,0,6);
  263.   SETCOLOR(BLACK);
  264.  
  265.   FFSetTextOptions(0,FALSE);
  266.   FFStringOutXY(30,20,'''FreeFont'' text can be');
  267.  
  268.   FFSetTextOptions(-15,FALSE);
  269.   FFStringOutXY(30,60,'Italics');
  270.  
  271.   FFSetTextOptions(0,TRUE);
  272.   FFStringOutXY(30,100,'Bold');
  273.  
  274.   FFSetTextOptions(-15,TRUE);
  275.   FFStringOutXY(30,140,'or BOTH');
  276. END;
  277.  
  278. PROCEDURE welcome;
  279. BEGIN
  280.   FFSetTextStyle(@FontBuffer,0,14);
  281.   FFSetTextOptions(0,TRUE);
  282.   SETCOLOR(YELLOW);
  283.   CircleText(GETMAXX div 2,GETMAXY + GETMAXY div 8,480,TOPTEXT,LIGHTBLUE,1,'Welcome',117);
  284.   CircleText(GETMAXX div 2,GETMAXY div -8,480,BOTTOMTEXT,LIGHTBLUE,-1,'''FreeFont''',239);
  285.   FFSetTextStyle(@FontBuffer,0,7);
  286.   FFSetTextOptions(0,TRUE);
  287.   SETTEXTJUSTIFY(CENTERTEXT,BOTTOMTEXT);
  288.   FFStringOutXY(GETMAXX div 2 ,GETMAXY div 2,'to');
  289.  
  290. END;
  291.  
  292. FUNCTION Finished:boolean;
  293. VAR
  294.       ch : Char;
  295.        d : longint;
  296.     done : boolean;
  297. BEGIN
  298.   d := 0;
  299.   done := FALSE;
  300.   SETCOLOR(WHITE);
  301.   SETTEXTJUSTIFY(CENTERTEXT,BOTTOMTEXT);
  302.   OUTTEXTXY(GETMAXX div 2,GETMAXY - 5,'Press any key to QUIT');
  303.   REPEAT
  304.     IF KEYPRESSED THEN
  305.     BEGIN
  306.       ch := readkey;
  307.       IF ch = #0 THEN ch := readkey;
  308.       done := TRUE;
  309.     END ELSE INC(d);
  310.   UNTIL done or (d=400000);
  311.   Finished := done;
  312. END;
  313.  
  314. PROCEDURE continue;
  315. VAR
  316.       ch : Char;
  317.        d : longint;
  318.     done : boolean;
  319. BEGIN
  320.   d := 0;
  321.   done := FALSE;
  322.   SETCOLOR(WHITE);
  323.   SETTEXTJUSTIFY(CENTERTEXT,BOTTOMTEXT);
  324.   OUTTEXTXY(GETMAXX div 2,GETMAXY - 5,'Press any key to continue');
  325.   REPEAT
  326.     IF KEYPRESSED THEN
  327.     BEGIN
  328.       ch := readkey;
  329.       IF ch = #0 THEN ch := readkey;
  330.       Done := TRUE;
  331.     END ELSE INC(d);
  332.   UNTIL done or (d=100000);
  333.   ClearScreen(LIGHTBLUE);
  334. END;
  335.  
  336. BEGIN
  337.   InitGraphics;
  338.  
  339.   IF LoadFont('trip.chr') THEN
  340.   BEGIN
  341.  
  342.     REPEAT
  343.  
  344.       ClearScreen(LIGHTBLUE);
  345.  
  346.       Welcome;
  347.       continue;
  348.  
  349.       FeatureDemo;
  350.       continue;
  351.  
  352.       RotateDemo;
  353.       continue;
  354.  
  355.       CircDemoI;
  356.       continue;
  357.  
  358.       CircDemoII;
  359.       continue;
  360.  
  361.       MirrorDemo;
  362.       continue;
  363.  
  364.       ShadowDemo;
  365.       continue;
  366.  
  367.       LastPage;
  368.  
  369.     UNTIL finished;
  370.  
  371.     restorecrtmode;
  372.  
  373.   END
  374.   ELSE BEGIN
  375.          restorecrtmode;
  376.          writeln('Error Loading the Font File.');
  377.        END;
  378. END.
  379.  
  380.